home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / lpr.el.z / lpr.el
Encoding:
Text File  |  1998-05-21  |  7.9 KB  |  242 lines
  1. ;;; lpr.el --- print Emacs buffer on line printer.
  2.  
  3. ;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: unix
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23. ;; 02111-1307, USA.
  24.  
  25. ;;; Synched up with: FSF 19.34.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; Commands to send the region or a buffer your printer.  Entry points
  30. ;; are `lpr-buffer', `print-buffer', lpr-region', or `print-region'; option
  31. ;; variables include `lpr-switches' and `lpr-command'.
  32.  
  33. ;;; Code:
  34.  
  35. (defgroup lpr nil
  36.   "Print Emacs buffer on line printer"
  37.   :group 'wp)
  38.  
  39.  
  40. ;;;###autoload
  41. (defcustom lpr-switches nil 
  42.   "*List of strings to pass as extra options for the printer program.
  43. See `lpr-command'."
  44.   :type '(repeat (string :tag "Argument"))
  45.   :group 'lpr)
  46.  
  47. (defcustom lpr-add-switches (eq system-type 'berkeley-unix)
  48.   "*Non-nil means construct -T and -J options for the printer program.
  49. These are made assuming that the program is `lpr';
  50. if you are using some other incompatible printer program,
  51. this variable should be nil."
  52.   :type 'boolean
  53.   :group 'lpr)
  54.  
  55. ;;;###autoload
  56. (defcustom lpr-command
  57.   (if (memq system-type '(usg-unix-v dgux hpux irix))
  58.       "lp" "lpr")
  59.   "*Name of program for printing a file."
  60.   :type 'string
  61.   :group 'lpr)
  62.  
  63. ;; Default is nil, because that enables us to use pr -f
  64. ;; which is more reliable than pr with no args, which is what lpr -p does.
  65. (defcustom lpr-headers-switches nil
  66.   "*List of strings of options to request page headings in the printer program.
  67. If nil, we run `lpr-page-header-program' to make page headings
  68. and print the result."
  69.   :type '(repeat (string :tag "Argument"))
  70.   :group 'lpr)
  71.  
  72. (defcustom print-region-function nil
  73.   "Function to call to print the region on a printer.
  74. See definition of `print-region-1' for calling conventions."
  75.   :type 'function
  76.   :group 'lpr)
  77.  
  78. (defcustom lpr-page-header-program "pr"
  79.   "*Name of program for adding page headers to a file."
  80.   :type 'string
  81.   :group 'lpr)
  82.  
  83. (defcustom lpr-page-header-switches '("-f")
  84.   "*List of strings to use as options for the page-header-generating program.
  85. The variable `lpr-page-header-program' specifies the program to use."
  86.   :type '(repeat string)
  87.   :group 'lpr)
  88.  
  89. ;;;###autoload
  90. (defun lpr-buffer ()
  91.   "Print buffer contents as with Unix command `lpr'.
  92. `lpr-switches' is a list of extra switches (strings) to pass to lpr."
  93.   (interactive)
  94.   (print-region-1 (point-min) (point-max) lpr-switches nil))
  95.  
  96. ;;;###autoload
  97. (defun print-buffer ()
  98.   "Print buffer contents as with Unix command `lpr -p'.
  99. `lpr-switches' is a list of extra switches (strings) to pass to lpr."
  100.   (interactive)
  101.   (print-region-1 (point-min) (point-max) lpr-switches t))
  102.  
  103. ;;;###autoload
  104. (defun lpr-region (start end)
  105.   "Print region contents as with Unix command `lpr'.
  106. `lpr-switches' is a list of extra switches (strings) to pass to lpr."
  107.   (interactive "r")
  108.   (print-region-1 start end lpr-switches nil))
  109.  
  110. ;;;###autoload
  111. (defun print-region (start end)
  112.   "Print region contents as with Unix command `lpr -p'.
  113. `lpr-switches' is a list of extra switches (strings) to pass to lpr."
  114.   (interactive "r")
  115.   (print-region-1 start end lpr-switches t))
  116.  
  117. ;; XEmacs change
  118. ;; (require 'message)    ; Until We can get some sensible autoloads, or
  119.             ; message-flatten-list gets put somewhere decent.
  120. ;; Sigh ...
  121. ;; `ps-flatten-list' is defined here (copied from "message.el" and
  122. ;; enhanced to handle dotted pairs as well) until we can get some
  123. ;; sensible autoloads, or `flatten-list' gets put somewhere decent.
  124.  
  125. ;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j))
  126. ;; => (a b c d e f g h i j)
  127.  
  128. (defun lpr-flatten-list (&rest list)
  129.   (lpr-flatten-list-1 list))
  130.  
  131. (defun lpr-flatten-list-1 (list)
  132.   (cond
  133.     ((null list) (list))
  134.     ((consp list)
  135.      (append (lpr-flatten-list-1 (car list))
  136.          (lpr-flatten-list-1 (cdr list))))
  137.     (t (list list))))
  138.  
  139. (defun print-region-1 (start end switches page-headers)
  140.   ;; On some MIPS system, having a space in the job name
  141.   ;; crashes the printer demon.  But using dashes looks ugly
  142.   ;; and it seems to annoying to do for that MIPS system.
  143.   (let ((name (concat (buffer-name) " Emacs buffer"))
  144.     (title (concat (buffer-name) " Emacs buffer"))
  145.     ;; On MS-DOS systems, make pipes use binary mode if the
  146.     ;; original file is binary.
  147.     (binary-process-input buffer-file-type)
  148.     (binary-process-output buffer-file-type)
  149.     (width tab-width)
  150.     nswitches
  151.     switch-string)
  152.     (save-excursion
  153.       (if page-headers
  154.       (if lpr-headers-switches
  155.           ;; It is possible to use an lpr option
  156.           ;; to get page headers.
  157.           (setq switches (append (if (stringp lpr-headers-switches)
  158.                      (list lpr-headers-switches)
  159.                         lpr-headers-switches)
  160.                      switches))))
  161.       (setq nswitches (lpr-flatten-list    ; XEmacs
  162.                (mapcar '(lambda (arg)  ; Dynamic evaluation
  163.                   (cond ((stringp arg) arg)
  164.                     ((functionp arg) (apply arg nil))
  165.                     ((symbolp arg) (eval arg))
  166.                     ((consp arg) (apply (car arg)
  167.                                 (cdr arg)))
  168.                     (t nil)))
  169.                    switches)))
  170.       (setq switch-string
  171.         (if nswitches (concat " with options "
  172.                  (mapconcat 'identity nswitches " "))
  173.           ""))
  174.       (message "Spooling%s..." switch-string)
  175.       (if (/= tab-width 8)
  176.       (let ((new-coords (print-region-new-buffer start end)))
  177.         (setq start (car new-coords) end (cdr new-coords))
  178.         (setq tab-width width)
  179.         (save-excursion
  180.           (goto-char end)
  181.           (setq end (point-marker)))
  182.         (untabify (point-min) (point-max))))
  183.       (if page-headers
  184.       (if lpr-headers-switches
  185.           ;; We handled this above by modifying SWITCHES.
  186.           nil
  187.         ;; Run a separate program to get page headers.
  188.         (let ((new-coords (print-region-new-buffer start end)))
  189.           (setq start (car new-coords) end (cdr new-coords)))
  190.         (apply 'call-process-region start end lpr-page-header-program
  191.                  t t nil
  192.                  (nconc (and lpr-add-switches
  193.                          (list "-h" title))
  194.                     lpr-page-header-switches))
  195.         (setq start (point-min) end (point-max))))
  196.       (apply (or print-region-function 'call-process-region)
  197.          (nconc (list start end lpr-command
  198.               nil nil nil)
  199.             (nconc (and lpr-add-switches
  200.                 (list "-J" name))
  201.                ;; These belong in pr if we are using that.
  202.                (and lpr-add-switches lpr-headers-switches
  203.                 (list "-T" title))
  204.                nswitches)))
  205.       (if (markerp end)
  206.       (set-marker end nil))
  207.       (message "Spooling%s...done" switch-string))))
  208.  
  209. ;; This function copies the text between start and end
  210. ;; into a new buffer, makes that buffer current.
  211. ;; It returns the new range to print from the new current buffer
  212. ;; as (START . END).
  213.  
  214. (defun print-region-new-buffer (ostart oend)
  215.   (if (string= (buffer-name) " *spool temp*")
  216.       (cons ostart oend)
  217.     (let ((oldbuf (current-buffer)))
  218.       (set-buffer (get-buffer-create " *spool temp*"))
  219.       (widen) (erase-buffer)
  220.       (insert-buffer-substring oldbuf ostart oend)
  221.       (cons (point-min) (point-max)))))
  222.  
  223. (defun printify-region (begin end)
  224.   "Turn nonprinting characters (other than TAB, LF, SPC, RET, and FF)
  225. in the current buffer into printable representations as control or
  226. hexadecimal escapes."
  227.   (interactive "r")
  228.   (save-excursion
  229.     (goto-char begin)
  230.     (let (c)
  231.       (while (re-search-forward "[\^@-\^h\^k\^n-\^_\177-\377]" end t)
  232.     (setq c (preceding-char))
  233.     (delete-backward-char 1)
  234.     (insert 
  235.      (if (< c ?\ )
  236.          (format "\\^%c" (+ c ?@))
  237.        (format "\\%02x" c)))))))
  238.  
  239. (provide 'lpr)
  240.  
  241. ;;; lpr.el ends here
  242.